home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / XLSYM.C < prev    next >
Text File  |  1985-12-01  |  5KB  |  230 lines
  1. /* xlsym - symbol handling routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *obarray,*s_unbound,*self;
  10. extern NODE ***xlstack,*xlenv;
  11.  
  12. /* forward declarations */
  13. FORWARD NODE *findprop();
  14.  
  15. /* xlenter - enter a symbol into the obarray */
  16. NODE *xlenter(name,type)
  17.   char *name; int type;
  18. {
  19.     NODE ***oldstk,*sym,*array;
  20.     int i;
  21.  
  22.     /* check for nil */
  23.     if (strcmp(name,"NIL") == 0)
  24.     return (NIL);
  25.  
  26.     /* check for symbol already in table */
  27.     array = getvalue(obarray);
  28.     i = hash(name,HSIZE);
  29.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  30.     if (strcmp(name,getstring(getpname(car(sym)))) == 0)
  31.         return (car(sym));
  32.  
  33.     /* make a new symbol node and link it into the list */
  34.     oldstk = xlsave(&sym,NULL);
  35.     sym = consd(getelement(array,i));
  36.     rplaca(sym,xlmakesym(name,type));
  37.     setelement(array,i,sym);
  38.     xlstack = oldstk;
  39.  
  40.     /* return the new symbol */
  41.     return (car(sym));
  42. }
  43.  
  44. /* xlsenter - enter a symbol with a static print name */
  45. NODE *xlsenter(name)
  46.   char *name;
  47. {
  48.     return (xlenter(name,STATIC));
  49. }
  50.  
  51. /* xlmakesym - make a new symbol node */
  52. NODE *xlmakesym(name,type)
  53.   char *name;
  54. {
  55.     NODE *sym;
  56.     sym = (type == DYNAMIC ? cvsymbol(name) : cvcsymbol(name));
  57.     setvalue(sym,*name == ':' ? sym : s_unbound);
  58.     return (sym);
  59. }
  60.  
  61. /* xlframe - create a new environment frame */
  62. NODE *xlframe(env)
  63.   NODE *env;
  64. {
  65.     return (consd(env));
  66. }
  67.  
  68. /* xlbind - bind a value to a symbol */
  69. xlbind(sym,val,env)
  70.   NODE *sym,*val,*env;
  71. {
  72.     NODE *ptr;
  73.  
  74.     /* create a new environment list entry */
  75.     ptr = consd(car(env));
  76.     rplaca(env,ptr);
  77.  
  78.     /* create a new variable binding */
  79.     rplaca(ptr,cons(sym,val));
  80. }
  81.  
  82. /* xlgetvalue - get the value of a symbol (checked) */
  83. NODE *xlgetvalue(sym)
  84.   NODE *sym;
  85. {
  86.     register NODE *val;
  87.     while ((val = xlxgetvalue(sym)) == s_unbound)
  88.     xlunbound(sym);
  89.     return (val);
  90. }
  91.  
  92. /* xlxgetvalue - get the value of a symbol */
  93. NODE *xlxgetvalue(sym)
  94.   NODE *sym;
  95. {
  96.     register NODE *fp,*ep;
  97.     NODE *val;
  98.  
  99.     /* check for this being an instance variable */
  100.     if (getvalue(self) && xlobgetvalue(sym,&val))
  101.     return (val);
  102.  
  103.     /* check the environment list */
  104.     for (fp = xlenv; fp; fp = cdr(fp))
  105.     for (ep = car(fp); ep; ep = cdr(ep))
  106.         if (sym == car(car(ep)))
  107.         return (cdr(car(ep)));
  108.  
  109.     /* return the global value */
  110.     return (getvalue(sym));
  111. }
  112.  
  113. /* xlygetvalue - get the value of a symbol (no instance variables) */
  114. NODE *xlygetvalue(sym)
  115.   NODE *sym;
  116. {
  117.     register NODE *fp,*ep;
  118.  
  119.     /* check the environment list */
  120.     for (fp = xlenv; fp; fp = cdr(fp))
  121.     for (ep = car(fp); ep; ep = cdr(ep))
  122.         if (sym == car(car(ep)))
  123.         return (cdr(car(ep)));
  124.  
  125.     /* return the global value */
  126.     return (getvalue(sym));
  127. }
  128.  
  129. /* xlsetvalue - set the value of a symbol */
  130. xlsetvalue(sym,val)
  131.   NODE *sym,*val;
  132. {
  133.     register NODE *fp,*ep;
  134.  
  135.     /* check for this being an instance variable */
  136.     if (getvalue(self) && xlobsetvalue(sym,val))
  137.     return;
  138.  
  139.     /* look for the symbol in the environment list */
  140.     for (fp = xlenv; fp; fp = cdr(fp))
  141.     for (ep = car(fp); ep; ep = cdr(ep))
  142.         if (sym == car(car(ep))) {
  143.         rplacd(car(ep),val);
  144.         return;
  145.         }
  146.  
  147.     /* store the global value */
  148.     setvalue(sym,val);
  149. }
  150.  
  151. /* xlgetprop - get the value of a property */
  152. NODE *xlgetprop(sym,prp)
  153.   NODE *sym,*prp;
  154. {
  155.     NODE *p;
  156.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  157. }
  158.  
  159. /* xlputprop - put a property value onto the property list */
  160. xlputprop(sym,val,prp)
  161.   NODE *sym,*val,*prp;
  162. {
  163.     NODE ***oldstk,*p,*pair;
  164.     if ((pair = findprop(sym,prp)) == NIL) {
  165.     oldstk = xlsave(&p,NULL);
  166.     p = consa(prp);
  167.     rplacd(p,pair = cons(val,getplist(sym)));
  168.     setplist(sym,p);
  169.     xlstack = oldstk;
  170.     }
  171.     rplaca(pair,val);
  172. }
  173.  
  174. /* xlremprop - remove a property from a property list */
  175. xlremprop(sym,prp)
  176.   NODE *sym,*prp;
  177. {
  178.     NODE *last,*p;
  179.     last = NIL;
  180.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  181.     if (car(p) == prp)
  182.         if (last)
  183.         rplacd(last,cdr(cdr(p)));
  184.         else
  185.         setplist(sym,cdr(cdr(p)));
  186.     last = cdr(p);
  187.     }
  188. }
  189.  
  190. /* findprop - find a property pair */
  191. LOCAL NODE *findprop(sym,prp)
  192.   NODE *sym,*prp;
  193. {
  194.     NODE *p;
  195.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  196.     if (car(p) == prp)
  197.         return (cdr(p));
  198.     return (NIL);
  199. }
  200.  
  201. /* hash - hash a symbol name string */
  202. int hash(str,len)
  203.   char *str;
  204. {
  205.     int i;
  206.     for (i = 0; *str; )
  207.     i = (i << 2) ^ *str++;
  208.     i %= len;
  209.     return (abs(i));
  210. }
  211.  
  212. /* xlsinit - symbol initialization routine */
  213. xlsinit()
  214. {
  215.     NODE *array,*p;
  216.  
  217.     /* initialize the obarray */
  218.     obarray = xlmakesym("*OBARRAY*",STATIC);
  219.     array = newvector(HSIZE);
  220.     setvalue(obarray,array);
  221.  
  222.     /* add the symbol *OBARRAY* to the obarray */
  223.     p = consa(obarray);
  224.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  225.  
  226.     /* enter the unbound symbol indicator */
  227.     s_unbound = xlsenter("*UNBOUND*");
  228.     setvalue(s_unbound,s_unbound);
  229. }
  230.